home *** CD-ROM | disk | FTP | other *** search
/ HAM Radio 1997 / HAM Radio 1997.iso / vcls / reswtch2 / gauges.pas < prev    next >
Pascal/Delphi Source File  |  1996-04-08  |  11KB  |  426 lines
  1. { Modified version of the standard gauges component to add some needed
  2.   functionality.  It now allows Text to be entered into the gauge by setting
  3.   the caption.  It also allows the font color to be adjusted.
  4.  
  5.   Modifications by
  6.  
  7.   Curtis White
  8.   President, TechnoSoft
  9. }
  10.  
  11. unit Gauges;
  12.  
  13. interface
  14.  
  15. uses WinTypes, Messages, Classes, Graphics, Controls, Forms, StdCtrls;
  16.  
  17. type
  18.  
  19.   TGaugeKind = (gkText, gkHorizontalBar, gkVerticalBar, gkPie, gkNeedle);
  20.  
  21.   TGauge = class(TGraphicControl)
  22.   private
  23.     FMinValue: Longint;
  24.     FMaxValue: Longint;
  25.     FCurValue: Longint;
  26.     FKind: TGaugeKind;
  27.     FShowText: Boolean;
  28.     FShowPercent: Boolean;
  29.     FBorderStyle: TBorderStyle;
  30.     FForeColor: TColor;
  31.     FBackColor: TColor;
  32.     procedure PaintBackground(AnImage: TBitmap);
  33.     procedure PaintAsText(AnImage: TBitmap; PaintRect: TRect);
  34.     procedure PaintAsNothing(AnImage: TBitmap; PaintRect: TRect);
  35.     procedure PaintAsBar(AnImage: TBitmap; PaintRect: TRect);
  36.     procedure PaintAsPie(AnImage: TBitmap; PaintRect: TRect);
  37.     procedure PaintAsNeedle(AnImage: TBitmap; PaintRect: TRect);
  38.     procedure SetGaugeKind(Value: TGaugeKind);
  39.     procedure SetShowText(Value: Boolean);
  40.     procedure SetShowPercent(Value: Boolean);
  41.     procedure SetBorderStyle(Value: TBorderStyle);
  42.     procedure SetForeColor(Value: TColor);
  43.     procedure SetBackColor(Value: TColor);
  44.     procedure SetMinValue(Value: Longint);
  45.     procedure SetMaxValue(Value: Longint);
  46.     procedure SetProgress(Value: Longint);
  47.     function GetPercentDone: Longint;
  48.   protected
  49.     procedure Paint; override;
  50.   public
  51.     constructor Create(AOwner: TComponent); override;
  52.     procedure AddProgress(Value: Longint);
  53.     property PercentDone: Longint read GetPercentDone;
  54.   published
  55.     property Align;
  56.     property Color;
  57.     property Caption;
  58.     property Enabled;
  59.     property Kind: TGaugeKind read FKind write SetGaugeKind default gkHorizontalBar;
  60.     property ShowText: Boolean read FShowText write SetShowText default False;
  61.     property ShowPercent: Boolean read FShowPercent write SetShowPercent default True;
  62.     property Font;
  63.     property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsSingle;
  64.     property ForeColor: TColor read FForeColor write SetForeColor default clBlack;
  65.     property BackColor: TColor read FBackColor write SetBackColor default clWhite;
  66.     property MinValue: Longint read FMinValue write SetMinValue default 0;
  67.     property MaxValue: Longint read FMaxValue write SetMaxValue default 100;
  68.     property ParentColor;
  69.     property ParentFont;
  70.     property ParentShowHint;
  71.     property Progress: Longint read FCurValue write SetProgress;
  72.     property ShowHint;
  73.     property Visible;
  74.   end;
  75.  
  76. implementation
  77.  
  78. uses WinProcs, SysUtils;
  79.  
  80. type
  81.   TBltBitmap = class(TBitmap)
  82.     procedure MakeLike(ATemplate: TBitmap);
  83.   end;
  84.  
  85. procedure TBltBitmap.MakeLike(ATemplate: TBitmap);
  86. begin
  87.   Width := ATemplate.Width;
  88.   Height := ATemplate.Height;
  89.   Canvas.Brush.Color := clWindowFrame;
  90.   Canvas.Brush.Style := bsSolid;
  91.   Canvas.FillRect(Rect(0, 0, Width, Height));
  92. end;
  93.  
  94. { This function solves for x in the equation "x is y% of z". }
  95. function SolveForX(Y, Z: Longint): Integer;
  96. begin
  97.   SolveForX := Trunc( Z * (Y * 0.01) );
  98. end;
  99.  
  100. { This function solves for y in the equation "x is y% of z". }
  101. function SolveForY(X, Z: Longint): Integer;
  102. begin
  103.   if Z = 0 then SolveForY := 0
  104.   else SolveForY := Trunc( (X * 100) / Z );
  105. end;
  106.  
  107. { TGauge }
  108. constructor TGauge.Create(AOwner: TComponent);
  109. begin
  110.   inherited Create(AOwner);
  111.   ControlStyle := ControlStyle + [csFramed, csOpaque];
  112.   { default values }
  113.   FMinValue := 0;
  114.   FMaxValue := 100;
  115.   FCurValue := 0;
  116.   FKind := gkHorizontalBar;
  117.   FShowText := False;
  118.   FShowPercent := True;
  119.   FBorderStyle := bsSingle;
  120.   FForeColor := clBlack;
  121.   FBackColor := clWhite;
  122.   Width := 100;
  123.   Height := 100;
  124. end;
  125.  
  126. function TGauge.GetPercentDone: Longint;
  127. begin
  128.   GetPercentDone := SolveForY(FCurValue - FMinValue, FMaxValue - FMinValue);
  129. end;
  130.  
  131. procedure TGauge.Paint;
  132. var
  133.   TheImage: TBitmap;
  134.   OverlayImage: TBltBitmap;
  135.   PaintRect: TRect;
  136. begin
  137.   with Canvas do
  138.   begin
  139.     TheImage := TBitmap.Create;
  140.     try
  141.       TheImage.Height := Height;
  142.       TheImage.Width := Width;
  143.       PaintBackground(TheImage);
  144.       PaintRect := ClientRect;
  145.       if FBorderStyle = bsSingle then InflateRect(PaintRect, -1, -1);
  146.       OverlayImage := TBltBitmap.Create;
  147.       try
  148.         OverlayImage.MakeLike(TheImage);
  149.         PaintBackground(OverlayImage);
  150.         case FKind of
  151.           gkText: PaintAsNothing(OverlayImage, PaintRect);
  152.           gkHorizontalBar, gkVerticalBar: PaintAsBar(OverlayImage, PaintRect);
  153.           gkPie: PaintAsPie(OverlayImage, PaintRect);
  154.           gkNeedle: PaintAsNeedle(OverlayImage, PaintRect);
  155.         end;
  156.         TheImage.Canvas.CopyMode := cmSrcInvert;
  157.         TheImage.Canvas.Draw(0, 0, OverlayImage);
  158.         TheImage.Canvas.CopyMode := cmSrcCopy;
  159.         if ShowText or ShowPercent then PaintAsText(TheImage, PaintRect);
  160.       finally
  161.         OverlayImage.Free;
  162.       end;
  163.       Canvas.CopyMode := cmSrcCopy;
  164.       Canvas.Draw(0, 0, TheImage);
  165.     finally
  166.       TheImage.Destroy;
  167.     end;
  168.   end;
  169. end;
  170.  
  171. procedure TGauge.PaintBackground(AnImage: TBitmap);
  172. var
  173.   ARect: TRect;
  174. begin
  175.   with AnImage.Canvas do
  176.   begin
  177.     CopyMode := cmBlackness;
  178.     ARect := Rect(0, 0, Width, Height);
  179.     CopyRect(ARect, Animage.Canvas, ARect);
  180.     CopyMode := cmSrcCopy;
  181.   end;
  182. end;
  183.  
  184. procedure TGauge.PaintAsText(AnImage: TBitmap; PaintRect: TRect);
  185. var
  186.   S: string;
  187.   X, Y: Integer;
  188.   OverRect: TBltBitmap;
  189. begin
  190.   OverRect := TBltBitmap.Create;
  191.   try
  192.     OverRect.MakeLike(AnImage);
  193.     PaintBackground(OverRect);
  194.     if ShowPercent and ShowText then
  195.       S := Caption + ': ' + Format('%d%%', [PercentDone])
  196.     else
  197.     begin
  198.       if ShowPercent then
  199.         S := Format('%d%%', [PercentDone])
  200.       else
  201.         S := Caption;
  202.     end;
  203.     with OverRect.Canvas do
  204.     begin
  205.       Brush.Style := bsClear;
  206.       Font := Self.Font;
  207.       { Font.Color := clWhite;  }
  208.       with PaintRect do
  209.       begin
  210.         X := (Right - Left + 1 - TextWidth(S)) div 2;
  211.         Y := (Bottom - Top + 1 - TextHeight(S)) div 2;
  212.       end;
  213.       TextRect(PaintRect, X, Y, S);
  214.     end;
  215.     AnImage.Canvas.CopyMode := cmSrcInvert;
  216.     AnImage.Canvas.Draw(0, 0, OverRect);
  217.   finally
  218.     OverRect.Free;
  219.   end;
  220. end;
  221.  
  222. procedure TGauge.PaintAsNothing(AnImage: TBitmap; PaintRect: TRect);
  223. begin
  224.   with AnImage do
  225.   begin
  226.     Canvas.Brush.Color := BackColor;
  227.     Canvas.FillRect(PaintRect);
  228.   end;
  229. end;
  230.  
  231. procedure TGauge.PaintAsBar(AnImage: TBitmap; PaintRect: TRect);
  232. var
  233.   FillSize: Longint;
  234.   W, H: Integer;
  235. begin
  236.   W := PaintRect.Right - PaintRect.Left + 1;
  237.   H := PaintRect.Bottom - PaintRect.Top + 1;
  238.   with AnImage.Canvas do
  239.   begin
  240.     Brush.Color := BackColor;
  241.     FillRect(PaintRect);
  242.     Pen.Color := ForeColor;
  243.     Pen.Width := 1;
  244.     Brush.Color := ForeColor;
  245.     case FKind of
  246.       gkHorizontalBar:
  247.         begin
  248.           FillSize := SolveForX(PercentDone, W);
  249.           if FillSize > W then FillSize := W;
  250.           if FillSize > 0 then FillRect(Rect(PaintRect.Left, PaintRect.Top,
  251.             FillSize, H));
  252.         end;
  253.       gkVerticalBar:
  254.         begin
  255.           FillSize := SolveForX(PercentDone, H);
  256.           if FillSize >= H then FillSize := H - 1;
  257.           FillRect(Rect(PaintRect.Left, H - FillSize, W, H));
  258.         end;
  259.     end;
  260.   end;
  261. end;
  262.  
  263. procedure TGauge.PaintAsPie(AnImage: TBitmap; PaintRect: TRect);
  264. var
  265.   MiddleX, MiddleY: Integer;
  266.   Angle: Double;
  267.   X, Y, W, H: Integer;
  268.   OverRect: TBltBitmap;
  269. begin
  270.   W := PaintRect.Right - PaintRect.Left;
  271.   H := PaintRect.Bottom - PaintRect.Top;
  272.   if FBorderStyle = bsSingle then
  273.   begin
  274.     Inc(W);
  275.     Inc(H);
  276.   end;
  277.   with AnImage.Canvas do
  278.   begin
  279.     Brush.Color := Color;
  280.     FillRect(PaintRect);
  281.     Brush.Color := BackColor;
  282.     Pen.Color := ForeColor;
  283.     Pen.Width := 1;
  284.     Ellipse(PaintRect.Left, PaintRect.Top, W, H);
  285.     if PercentDone > 0 then
  286.     begin
  287.       Brush.Color := ForeColor;
  288.       MiddleX := W div 2;
  289.       MiddleY := H div 2;
  290.       Angle := (Pi * ((PercentDone / 50) + 0.5));
  291.       Pie(PaintRect.Left, PaintRect.Top, W, H, Round(MiddleX * (1 - Cos(Angle))),
  292.         Round(MiddleY * (1 - Sin(Angle))), MiddleX, 0);
  293.     end;
  294.   end;
  295. end;
  296.  
  297. procedure TGauge.PaintAsNeedle(AnImage: TBitmap; PaintRect: TRect);
  298. var
  299.   MiddleX: Integer;
  300.   Angle: Double;
  301.   X, Y, W, H: Integer;
  302.   OverRect: TBltBitmap;
  303. begin
  304.   with PaintRect do
  305.   begin
  306.     X := Left;
  307.     Y := Top;
  308.     W := Right - Left;
  309.     H := Bottom - Top;
  310.     if FBorderStyle = bsSingle then
  311.     begin
  312.       Inc(W);
  313.       Inc(H);
  314.     end;
  315.   end;
  316.   with AnImage.Canvas do
  317.   begin
  318.     Brush.Color := Color;
  319.     FillRect(PaintRect);
  320.     Brush.Color := BackColor;
  321.     Pen.Color := ForeColor;
  322.     Pen.Width := 1;
  323.     Pie(X, Y, W, H * 2 - 1, X + W, PaintRect.Bottom - 1, X, PaintRect.Bottom - 1);
  324.     MoveTo(X, PaintRect.Bottom);
  325.     LineTo(X + W, PaintRect.Bottom);
  326.     if PercentDone > 0 then
  327.     begin
  328.       Pen.Color := ForeColor;
  329.       MiddleX := Width div 2;
  330.       MoveTo(MiddleX, PaintRect.Bottom - 1);
  331.       Angle := (Pi * ((PercentDone / 100)));
  332.       LineTo(Round(MiddleX * (1 - Cos(Angle))), Round((PaintRect.Bottom - 1) *
  333.         (1 - Sin(Angle))));
  334.     end;
  335.   end;
  336. end;
  337.  
  338. procedure TGauge.SetGaugeKind(Value: TGaugeKind);
  339. begin
  340.   if Value <> FKind then
  341.   begin
  342.     FKind := Value;
  343.     Refresh;
  344.   end;
  345. end;
  346.  
  347. procedure TGauge.SetShowText(Value: Boolean);
  348. begin
  349.   if Value <> FShowText then
  350.   begin
  351.     FShowText := Value;
  352.     Refresh;
  353.   end;
  354. end;
  355.  
  356. procedure TGauge.SetShowPercent(Value: Boolean);
  357. begin
  358.   if Value <> FShowPercent then
  359.   begin
  360.     FShowPercent := Value;
  361.     Refresh;
  362.   end;
  363. end;
  364.  
  365. procedure TGauge.SetBorderStyle(Value: TBorderStyle);
  366. begin
  367.   if Value <> FBorderStyle then
  368.   begin
  369.     FBorderStyle := Value;
  370.     Refresh;
  371.   end;
  372. end;
  373.  
  374. procedure TGauge.SetForeColor(Value: TColor);
  375. begin
  376.   if Value <> FForeColor then
  377.   begin
  378.     FForeColor := Value;
  379.     Refresh;
  380.   end;
  381. end;
  382.  
  383. procedure TGauge.SetBackColor(Value: TColor);
  384. begin
  385.   if Value <> FBackColor then
  386.   begin
  387.     FBackColor := Value;
  388.     Refresh;
  389.   end;
  390. end;
  391.  
  392. procedure TGauge.SetMinValue(Value: Longint);
  393. begin
  394.   if Value <> FMinValue then
  395.   begin
  396.     FMinValue := Value;
  397.     Refresh;
  398.   end;
  399. end;
  400.  
  401. procedure TGauge.SetMaxValue(Value: Longint);
  402. begin
  403.   if Value <> FMaxValue then
  404.   begin
  405.     FMaxValue := Value;
  406.     Refresh;
  407.   end;
  408. end;
  409.  
  410. procedure TGauge.SetProgress(Value: Longint);
  411. begin
  412.   if (FCurValue <> Value) and (Value >= FMinValue) and (Value <= FMaxValue) then
  413.   begin
  414.     FCurValue := Value;
  415.     Refresh;
  416.   end;
  417. end;
  418.  
  419. procedure TGauge.AddProgress(Value: Longint);
  420. begin
  421.   Progress := FCurValue + Value;
  422.   Refresh;
  423. end;
  424.  
  425. end.
  426.